home *** CD-ROM | disk | FTP | other *** search
/ Wayzata's Best of Shareware PC/Windows 1 / Wayzata's Best of Shareware for PC-Windows - Release 1 - Wayzata Technology (1993).iso / mac / DOS / PROGRAMG / FORTHCMP / MULTI.4TH < prev    next >
Text File  |  1992-03-30  |  11KB  |  416 lines
  1. \ ForthCMP Multitasking Module 
  2. \ Copyright 1987 (C) By Thomas Almy.  All rights reserved.
  3.  
  4. \ Permission is granted to registered users of ForthCMP to sell or distribute
  5. \ computer programs incorporating the compiled contents of this file.
  6.  
  7. \ IBM BIOS is used for terminal I/O.
  8.  
  9. \ See the manual for usage of this module.
  10.  
  11. \   IBM is a trademark of International Business Machines, Inc.
  12.  
  13.  .( LOADING MULTI) CR
  14. INCLUDE INTS
  15. INCLUDE FARMEM1
  16. 10
  17.  
  18. DECIMAL  
  19.  
  20. 0 0 IN/OUT NEED SINGLE 
  21. 0 0 IN/OUT NEED MULTI
  22. 0 0 IN/OUT NEED PAUSE
  23. 0 0 IN/OUT NEED end-timer
  24. 0 0 IN/OUT NEED start-timer
  25.  
  26. VARIABLE ?multi         \ true if multitasking turned on
  27. VARIABLE user           \ disp into user segment--used at compile time
  28. VARIABLE CTASK          \ pointer to task list
  29. VARIABLE dispused       \ semaphore for display output
  30. VARIABLE inexpect       \ executing EXPECT -- only one at a time, please!
  31.  
  32.  \ Semaphores
  33.  
  34. 1 0 IN/OUT
  35. : SEMA  BEGIN DUP @ WHILE PAUSE REPEAT  ON ;
  36.  
  37. 1 0 IN/OUT
  38. : PHORE  OFF PAUSE ;
  39.  
  40.  
  41. 0 0 IN/OUT 
  42. : BYE  end-timer bye ;
  43.  
  44.  \ Memory management interface
  45. 1 1 IN/OUT
  46. : GET malloc IF    ." OUT OF MEMORY " BYE THEN ;
  47.  
  48.  \ USER VARIABLES 
  49. H: UALLOT  DSEG user @  +  user ! ;
  50. 1 2 IN/OUT
  51. H: UCREATE user @ CONSTANT ;
  52. H: UVARIABLE  UCREATE 2 UALLOT ;
  53. H: URESET DSEG  0 user ! ;
  54. URESET
  55.  \ redefinition of primitive I/O functions
  56. HEX
  57. 0 0 IN/OUT
  58. CODE setcursor  \ set the cursor to the correct location
  59.     CTASK [] BX MOV
  60.     CS: 12 +[BX] DH MOV     \ Y value
  61.     CS: 14 +[BX] DL MOV     \ X value
  62.     BH BH XOR
  63.     2 # AH MOV
  64.     10 INT
  65.     RET
  66. END-CODE \ setcursor
  67.  
  68. 0 0 IN/OUT
  69. CODE getcursor  \ get the correct cursor coordinates
  70.     3 # AH MOV
  71.     BH BH XOR
  72.     10 INT
  73.     CTASK [] BX MOV
  74.     DH CS: 12 +[BX] MOV     \ Y value
  75.     DL CS: 14 +[BX] MOV     \ X value
  76.     RET
  77. END-CODE \ getcursor
  78.  
  79. 2 0 IN/OUT
  80. : GOTOXY  CTASK @ 12 + CS: 2! ;
  81.  
  82. 0 2 IN/OUT
  83. : ?XY     CTASK @ 12 + CS: 2@ ;
  84.  
  85. 1 0 IN/OUT
  86. CODE emit
  87.     0E # AH MOV
  88.     BX BX XOR
  89.     10 INT
  90.     RET 
  91. END-CODE
  92.  
  93. 0 0 IN/OUT 
  94. CODE CLS
  95.     3 # AX MOV 
  96.     10 INT 
  97.     RET 
  98. END-CODE
  99.  
  100. 0 1 IN/OUT
  101. CODE ?TERMINAL 
  102.     CALL' PAUSE     \ allow another task to execute
  103.     1 # AH MOV 
  104.     16 INT 
  105.     0 # AX MOV
  106.     =0 ~ IF, AX DEC  THEN,
  107.     RET
  108. END-CODE \ ?TERMINAL
  109.  
  110. : PAD CTASK @ 16 + CS: @ ;
  111.  
  112. DECIMAL
  113.  
  114. : EMIT 
  115.     dispused SEMA 
  116.     setcursor
  117.     emit
  118.     getcursor
  119.     dispused PHORE ;
  120.  
  121. : TYPE 
  122.     dispused SEMA 
  123.     setcursor
  124.     0 ?DO COUNT emit LOOP DROP 
  125.     getcursor
  126.     dispused PHORE ;
  127.  
  128. : CS:TYPE
  129.     dispused SEMA
  130.     setcursor
  131.     0 ?DO CS: COUNT emit LOOP DROP
  132.     getcursor
  133.     dispused PHORE ;
  134.  
  135. : SPACES        \ send out all characters in a burst
  136.     dispused SEMA
  137.     setcursor
  138.     DUP 0> IF 0 DO BL emit LOOP  ELSE DROP THEN
  139.     getcursor
  140.     dispused PHORE ;
  141.  
  142.  
  143. : KEY  BEGIN ?TERMINAL setcursor UNTIL  0 8 BDOS ;
  144.  
  145.  \ EXPECT
  146.  
  147. FIND SPAN #IF DROP #ELSE VARIABLE SPAN #THEN
  148.  
  149. 0 0 IN/OUT
  150. : bu  8 emit BL emit 8 emit -1 SPAN +! ;
  151.  
  152. : EXPECT 
  153.     inexpect SEMA       \ too hard if two or more tasks want input at once!
  154.     >R SPAN OFF
  155.     BEGIN
  156.         SPAN @ R@ < WHILE       \ more room on line
  157.         KEY  dispused SEMA  setcursor  CASE
  158.         27 OF BEGIN SPAN @ 0> WHILE bu REPEAT  ENDOF
  159.         8  OF SPAN @ 0> IF bu THEN ENDOF
  160.         13 OF BL emit
  161.             R> DROP DROP 
  162.             getcursor 
  163.             dispused PHORE 
  164.             inexpect PHORE 
  165.             EXIT ENDOF
  166.         ( ELSE ) DUP emit 
  167.             OVER SPAN @ + C! 
  168.             1 SPAN +!
  169.         0 ENDCASE
  170.         getcursor dispused PHORE
  171.     REPEAT
  172.     inexpect PHORE
  173.     R> 2DROP ;
  174.  
  175.  
  176.  \ TASK CREATION 
  177. HEX
  178. H: TASK              \ values after INIT-TASKS:
  179.    CSEG FORCE CREATE HERE E92E , \ DISP 0 -- JMP ( task asleep )
  180.    DSEG CTASK @ ,  CTASK !    \     02 -- relative addr nxt task
  181.    user @ ,                   \     04 -- size of user area (not used?)
  182.    0 ,                        \     06 -- SS register contents
  183.    user @ pssize 10 * + ,     \     08 -- SP register contents
  184.    user @ pssize 10 * + rssize + , \     0A -- BP register contents
  185.    ,                          \     0C -- PC contents
  186. \ the following fields are for per-task variables
  187. \ and could be selectively elimiated if not needed if space is 
  188. \ at a premium.  In that case, offsets may need to be adjusted
  189. \ for words which use latter fields.
  190.    0 ,                        \     0E -- Message list
  191.    0 ,                        \     10 -- Timer
  192.    0 ,                        \     12 -- Y cursor coordinate
  193.    0 ,                        \     14 -- X cursor coordinate
  194.    DSEG HERE 80 ALLOT 20 + ,  \     16 -- PAD, a per-task work area
  195. ; 
  196. 0 #IF
  197. Initially, DISP 2 has absolute address of next task. 
  198. This value as well as DISP 6 get
  199. filled in by INIT-TASKS when application is run.
  200. #THEN
  201.  
  202. CSEG FORCE  HERE  CREATE MAIN-TASK  \ Give it a name
  203. DSEG CTASK !                  \ Task list points to it
  204. 80CD ,                        \ DISP 0 -- INT 80 (task awake)
  205.    0 ,                        \     02 -- relative addr next task
  206.    0 ,                        \     04 -- NOT USED
  207.    0 ,                        \     06 -- SS register contents
  208.    0 ,                        \     08 -- SP register contents
  209.    0 ,                        \     0A -- BP register contents
  210.    0 ,                        \     0C -- PC contents
  211.    0 ,                        \     0E -- Message list
  212.    0 ,                        \     10 -- Timer
  213.    0 ,                        \     12 -- Y cursor coordinate
  214.    0 ,                        \     14 -- X cursor coordinate
  215.    DSEG HERE 80 ALLOT 20 + ,  \     16 -- PAD, a per-task work area
  216. 0 #IF
  217. DISP-2, 6, 12, and 14 get filled in by INIT-TASK.  -8 -0A and -0C
  218. are filled by first task swap (which is done by INIT-TASK).
  219. #THEN
  220.  
  221.  \ TASK INITIALIZATION
  222. 0 0 IN/OUT 
  223. : INIT-TASKS \ This MUST be executed to start multitasking
  224.     CTASK @
  225.     BEGIN ?DUP WHILE  \ for each task DO:
  226.         2+ DUP CS: @ IF  \ one follows, this isn't main task
  227.             DUP 8 + CS: @ 10 + 4 >>  GET 
  228.          OVER 4 + CS: ! \ stackseg
  229.             DUP CS: @ TUCK   \ next task
  230.         ELSE
  231.             0 SWAP CTASK @ \ next task is head of list
  232.         THEN
  233.         OVER - 2- SWAP CS: !  
  234.     REPEAT
  235.     MAIN-TASK CTASK !  
  236.     getcursor       \ sets main task cursor
  237.     ?SS: MAIN-TASK 6 + CS: !    \ sets main task stack segment
  238.     start-timer
  239.     MULTI ( GO!!! ) ;
  240.  
  241.  \ TASK DISPATCHER
  242. CODE PAUSE  
  243.     0 # ?multi [] CMP  
  244.     =0 IF, RET THEN,
  245.     CTASK [] BX MOV         \ current task
  246.     CS: 0C +[BX] POP        \ save PC
  247.     BP CS: 0A +[BX] MOV     \ save BP
  248.     SP CS: 08 +[BX] MOV     \ save SP
  249.     CS: 2 +[BX] BX ADD  
  250.     4 # BX ADD  
  251.     CLI                \ no ints during dispatch
  252.     BX JMPI  ( dispatch )
  253. END-CODE \ PAUSE
  254.  
  255. 0 #IF
  256. Tasks are linked together so that jumping to a task will cause
  257. jumping to the next if it is asleep, or doing an INT 80 if it
  258. is awake.  Thanks to Henry Laxen's Forth 83 model for the
  259. technique.
  260. #THEN
  261.  
  262. L: start-task ( the INT80 routine )  
  263.     BX POP 
  264.     BX DEC 
  265.     BX DEC                  \ Pointer to the task
  266.     CS: 6 +[BX] SS >SEG     \ restore stack segment
  267.     CS: 8 +[BX] SP MOV      \ restore SP
  268.     STI                     \ Interrupts are safe now
  269.     CS: 0A +[BX] BP MOV     \ restore BP
  270.     BX  CTASK [] MOV        \ current task
  271.     CS: 0C +[BX] JMPI       \ go!
  272. FORTH \ start-task 
  273. 0 #IF
  274. This code starts up a new task by setting up all registers,
  275. fixing CTASK, and jumping to where we left off.
  276. #THEN
  277.  
  278.  \ TASK MANAGEMENT
  279. : SINGLE  ?multi OFF ;
  280.  
  281. : MULTI   ?multi ON
  282.     ?CS: start-task 0 200  2!L  \ install interrupt vector
  283.     PAUSE  \ start with a task swap
  284. ;
  285.  
  286. 1 0 IN/OUT
  287. : WAKE 80CD CS: <- ;
  288.  
  289. 1 0 IN/OUT
  290. \ the 2e prefix byte (CS override) makes the jmp instruction 4 bytes long
  291. : SLEEP (  task -- )   E92E CS: <- ;
  292.  
  293. 1 1 IN/OUT
  294. : WAITING?  10 + CS: @ 0<> ;
  295.  
  296. 0 0 IN/OUT
  297. : STOP  CTASK @ SLEEP PAUSE ;
  298.  
  299. 0 1 IN/OUT
  300. : ACTIVE-TASKS
  301.     0 CTASK @
  302.     BEGIN
  303.         DUP WAITING? IF SWAP 1+ SWAP ELSE 
  304.             DUP CS: @ 80CD = IF SWAP 1+ SWAP THEN THEN \ check for active
  305.         DUP 2+ CS: @ + 4 + \ address of next task
  306.     DUP CTASK @ = UNTIL     \ Loop until back to start
  307.     DROP ( task address )
  308. ;
  309.  
  310.  \ MESSAGE PASSING
  311. 0 1 IN/OUT
  312. : MESSAGE?  CTASK @ 0E + CS: @ ;
  313.  
  314. 0 1 IN/OUT
  315. : GET-MESSAGE  
  316.     BEGIN MESSAGE? ?DUP 0= WHILE STOP REPEAT
  317.     DUP  0 @L CTASK @ 0E + CS: !         \ Unlink message
  318. ;   
  319.  
  320. 1 1 IN/OUT
  321. : MESSAGES
  322.     0 SWAP 0E + CS: @ ?DUP IF
  323.         BEGIN SWAP 1+ SWAP  0 @L  ?DUP 0= UNTIL
  324.     THEN ;
  325.  
  326. 2 0 IN/OUT
  327. : SEND-MESSAGE 
  328.     OVER 0 SWAP 0 !L        \ set message's next field to NIL
  329.     DUP WAITING? NOT IF DUP WAKE THEN \ fire up receiving task
  330.                                 \ unless waiting for timer
  331.     0E + DUP CS: @ ?DUP IF  \ Existing messages in queue
  332.         NIP
  333.         BEGIN DUP 0 @L ?DUP WHILE NIP REPEAT \ find end of list
  334.         0 !L  \ store message at end of list
  335.     ELSE
  336.         CS: !     \ no existing messages, put at head of queue.
  337.     THEN
  338.     PAUSE ;  \ Give it a chance to run
  339.  
  340.  \ control-break handler
  341. \ always gets control and (currently) dumps task information
  342.  
  343. 2VARIABLE cb_save
  344.  
  345. 1B CONSTANT cb_int
  346.  
  347. 0 0 IN/OUT
  348. : cbt  
  349.     CLS 
  350.     SINGLE
  351.     end-timer
  352.     ." Task statistics: "
  353.     MAIN-TASK \ start with first
  354.     BEGIN CR
  355.         HEX DUP 0 <# # # # # #> TYPE SPACE \ address
  356.         DUP WAITING? IF ." Waiting " DUP 10 + CS: @ . ." ticks" ELSE 
  357.             DUP CS: @ 80CD = IF ." Active" ELSE ." Sleeping" THEN THEN 
  358.         DUP 2+ CS: @ + 4 + \ address of next task
  359.     DUP MAIN-TASK = UNTIL     \ Loop until back to start
  360.     DROP ( task address )
  361.     bye
  362. ;
  363.  
  364.  
  365. ' cbt TASK cb-task
  366.  
  367.  
  368. L: cb_handler ( actual interrupt handler )
  369.       80CD # CS: cb-task [] MOV \ wake cb task
  370.     STI
  371.     IRET FORTH
  372.  
  373.  
  374.  \ timer
  375.  
  376. 1C CONSTANT t_int               \ timer interupt vector number
  377. CSEG FORCE 
  378. CREATE t_save 4 ALLOT           \ original interupt vector
  379. L: t_handler
  380.     PUSHF CS: t_save CALLF    \ do original functions
  381.     BX PUSH
  382.     MAIN-TASK # BX MOV ( start of list )
  383.     BEGIN,  
  384.         CS: 0 # 10 +[BX] CMP =0 ~ IF, ( non_zero time )
  385.             CS: 10 +[BX] DEC  ( count down )
  386.             =0 IF, 80CD # CS: [BX] MOV THEN, ( wake task )
  387.         THEN,
  388.         CS: 2 +[BX] BX ADD 
  389.         4 # BX ADD ( next task )
  390.         MAIN-TASK # BX CMP  
  391.     =0 UNTIL, ( back at start? )
  392.     BX POP 
  393.     IRET
  394. FORTH \ t_handler
  395.  
  396. \ timer start and end                          08:09 11/18/85
  397.  
  398. : start-timer  \ and control-break handler
  399.     t_int get-handler  t_save CS: 2!
  400.     ?CS: t_handler t_int set-handler
  401.     cb_int get-handler cb_save 2!
  402.     ?CS: cb_handler cb_int set-handler
  403. ;
  404.  
  405. : end-timer
  406.     t_save CS: 2@  t_int set-handler
  407.     cb_save 2@ cb_int set-handler
  408. ;
  409.  
  410. 2 0 IN/OUT
  411. : TIME-OUT ( ticks task -- )  DUP SLEEP 10 + CS: ! ;
  412.  
  413. : WAIT ( ticks -- ) CTASK @ TIME-OUT PAUSE ;
  414.  
  415. DSEG 0A = #IF DECIMAL #THEN
  416.